home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / network / info-sys / www / tkhtml-2.3 / tkhtml-2 / tkHTML-2.3 / tix / PupMenu.tcl < prev    next >
Encoding:
Text File  |  1995-02-12  |  2.0 KB  |  84 lines
  1. # Local Prefix = _tixPP_ ; Meaning : TIX Popup
  2.  
  3. #----------------------------------------------------------------------
  4. #                         POPUP MENUS
  5. #----------------------------------------------------------------------
  6. proc tixCreatePopupMenu {w title mkmenu_proc} {
  7.     upvar #0 $w pop
  8.     set pop(widget)  $w
  9.     set pop(parents) {}
  10.  
  11.     toplevel $w -cursor arrow -class TixPopupMenu
  12.     wm overrideredirect $w 1
  13.     wm withdraw $w
  14.     menubutton $w.mb -text $title -menu $w.mb.m -anchor w
  15.     pack $w.mb -expand yes -fill both
  16.  
  17.     eval $mkmenu_proc $w.mb.m
  18.     
  19.     bind $w.mb <1>                  "_tixPP_Unpost $w"
  20.     bind $w.mb <3>                  "_tixPP_Unpost $w"
  21.     bind $w.mb.m <Unmap>            "+_tixPP_Unmap $w"
  22.     bind $w.mb.m <ButtonRelease-3>  {tk_invokeMenu %W}
  23.     foreach submenu [tixDescendants $w.mb.m] {
  24.     bind $submenu <ButtonRelease-3> {tk_invokeMenu %W}
  25.     }
  26. }
  27.  
  28. proc tixDestroyPopupMenu {w} {
  29.     upvar #0 $w pop
  30.  
  31.     foreach parent $pop(parents) {
  32.     bind $parent <3>         {}
  33.     bind $parent <Control-1> {}
  34.     }
  35.  
  36.     destroy $pop(widget)
  37.     unset pop
  38. }
  39.  
  40.  
  41. proc tixPupBindParents {w args} {
  42.     upvar #0 $w pop
  43.  
  44.     foreach parent $args {
  45.     bind $parent <3>         "_tixPP_Map $parent $w %x %y"
  46.  
  47.     if {[lsearch $pop(parents) $parent] == -1} {
  48.         lappend pop(parents) $parent
  49.     }
  50.     }
  51. }
  52.  
  53. proc _tixPP_Map {parent w x y} {
  54.     global tk_priv
  55.  
  56.     set width  [winfo reqwidth  $w]
  57.     set height [winfo reqheight $w]
  58.     wm geometry $w [format "%dx%d" [winfo reqwidth $w.mb.m] $height]    
  59.     set width  [winfo reqwidth  $w]
  60.  
  61.     set wx [expr [winfo rootx $parent] + $x - $width  / 2]
  62.     set wy [expr [winfo rooty $parent] + $y - $height / 2]
  63.  
  64.     wm geometry $w [format "+%d+%d" $wx $wy]
  65.     wm deiconify $w
  66.     raise $w
  67.  
  68.     update idletasks
  69.     grab -global $w
  70.     set tk_priv(inMenuButton) $w.mb 
  71.     tk_mbButtonDown $w.mb
  72. }
  73.  
  74. proc _tixPP_Unmap {w} {
  75.     grab release $w.mb
  76.     wm withdraw $w
  77. }
  78.  
  79. proc _tixPP_Unpost {w} {
  80.     grab release $w.mb
  81.     tk_mbUnpost
  82.     wm withdraw $w
  83. }
  84.